home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / Dev / Oberon / source / Kernel / Kernel.mod < prev    next >
Text File  |  1995-06-29  |  52KB  |  1,642 lines
  1. (**************************************************************************
  2.  
  3.      $RCSfile: Kernel.mod $
  4.   Description: Oberon-A run-time support module.
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 1.9 $
  8.       $Author: fjc $
  9.         $Date: 1995/06/15 18:30:11 $
  10.  
  11.   Copyright © 1994-1995, Frank Copeland.
  12.   This file is part of Oberon-A.
  13.   See Oberon-A.doc for conditions of use and distribution.
  14.  
  15.   Log entries are at the end of the file.
  16.   ________________________________________________________________________
  17.  
  18.   This module has a special status in the Oberon-A system. It is always
  19.   included in a program, even if no other module imports it. It is
  20.   *always* the first module that gets initialised at run-time, and it is
  21.   responsible for cleaning up the program's environment before it exits.
  22.   Procedures in this module are called directly by the compiler to
  23.   perform operations that are too complex to be coded inline.
  24.  
  25.   Assumptions about this module are hard-coded into the compiler, and you
  26.   change it at your peril. Those elements that must NOT be changed will
  27.   be clearly indicated in the associated commentary. The remaining
  28.   elements may be modified, but you must do so with extreme care.
  29.  
  30.   This module must be a leaf module. That is, it must not import from any
  31.   other module except SYSTEM. Any access to Amiga system software *must*
  32.   be through variables and types declared in this module.
  33.  
  34. **************************************************************************)
  35.  
  36. <* STANDARD- *> <* MAIN- *> <* INITIALISE- *>
  37.  
  38. (* Turn off ALL compiler checks. *)
  39.  
  40. <*$ CaseChk-  IndexChk- NilChk-  RangeChk-
  41.     StackChk- TypeChk-  OvflChk- ReturnChk- *>
  42.  
  43. (* Create selector for a debugging version *)
  44.  
  45. <* NEW DEBUG1 *> <* DEBUG1- *> (* Disabled *)
  46.  
  47. <* IF DEBUG1 THEN *>
  48. MODULE Kernel ["LMath.o", "MarkDbg.o"];
  49. <* ELSE *>
  50. MODULE Kernel ["LMath.o", "Mark.o"];
  51. <* END *>
  52.  
  53. IMPORT SYS := SYSTEM;
  54.  
  55.  
  56. (*-----------------------------------------------------------------------**
  57. ** Error codes used for HALT and ASSERT statements.                      **
  58. **-----------------------------------------------------------------------*)
  59.  
  60. CONST
  61.  
  62.   notAllocated    =  80;
  63.   userTrap        =  81;
  64.   outOfMem        =  95;
  65.   invariant       =  96;
  66.   preCondition    =  97;
  67.   postCondition   =  98;
  68.   notImplemented  =  99;
  69.   noLibrary       = 100;
  70.  
  71. (*-----------------------------------------------------------------------**
  72. ** The following declarations duplicate those in modules Exec and Dos,   **
  73. ** so that there is no need to import those modules.                     **
  74. **-----------------------------------------------------------------------*)
  75.  
  76.  
  77. CONST
  78.  
  79.   memAny       = {};
  80.   memPublic    = 0;
  81.   memChip      = 1;
  82.   memFast      = 2;
  83.   memLocal     = 8;
  84.   mem24BitDMA  = 9;
  85.   memKick      = 10;
  86.  
  87.   memClear     = 16;
  88.   memLargest   = 17;
  89.   memReverse   = 18;
  90.   memTotal     = 19;
  91.  
  92.   memNoExpunge = 31;
  93.  
  94. TYPE
  95.  
  96.   LibraryPtr = POINTER [1] TO Library;
  97.   Library = RECORD [1] END;
  98.   ExecBasePtr = POINTER [1] TO ExecBase;
  99.   ExecBase = RECORD [1] (Library) END;
  100.   PROC = PROCEDURE;
  101.   STRPTR = POINTER [1] TO ARRAY 32767 OF CHAR;
  102.   BSET = SYS.BYTESET;
  103.   WSET = SYS.WORDSET;
  104.   APTR = SYS.ADDRESS;
  105.   UBYTE = SYS.BYTE;
  106.  
  107.   MinNodePtr = POINTER [1] TO MinNode;
  108.   MinNode = RECORD [1]
  109.     succ : MinNodePtr;
  110.     pred : MinNodePtr;
  111.   END;
  112.  
  113.   NodePtr = POINTER [1] TO Node;
  114.   Node = RECORD [1]
  115.     succ    : NodePtr;
  116.     pred    : NodePtr;
  117.     type    : UBYTE;
  118.     pri     : SHORTINT;
  119.     namePtr : STRPTR;
  120.   END;
  121.  
  122.   MinList = RECORD [1]
  123.     head     : MinNodePtr;
  124.     tail     : MinNodePtr;
  125.     tailPred : MinNodePtr;
  126.   END;
  127.  
  128.   List = RECORD [1]
  129.     head     : NodePtr;
  130.     tail     : NodePtr;
  131.     tailPred : NodePtr;
  132.     type     : UBYTE;
  133.     pad      : UBYTE;
  134.   END;
  135.  
  136.   TaskPtr = POINTER [1] TO Task;
  137.   Task = RECORD [1] (Node)
  138.     tcFlags    : BSET;
  139.     state      : BSET;
  140.     idNestCnt  : SHORTINT;
  141.     tdNestCnt  : SHORTINT;
  142.     sigAlloc   : SET;
  143.     sigWait    : SET;
  144.     sigRecvd   : SET;
  145.     sigExcept  : SET;
  146.     trapAlloc  : WSET;
  147.     trapAble   : WSET;
  148.     exceptData : APTR;
  149.     exceptCode : PROC;
  150.     trapData   : APTR;
  151.     trapCode   : PROC;
  152.     spReg      : APTR;
  153.     spLower    : APTR;
  154.     spUpper    : APTR;
  155.     switch     : PROC;
  156.     launch     : PROC;
  157.     memEntry   : List;
  158.     userData   : APTR;
  159.   END;
  160.  
  161.   MsgPort = RECORD [1] (Node)
  162.     mpFlags : BSET;
  163.     sigBit  : SHORTINT;
  164.     sigTask : TaskPtr;
  165.     msgList : List;
  166.   END;
  167.  
  168.   ProcessPtr = POINTER [1] TO Process;
  169.   Process = RECORD [1] (Task)
  170.     msgPort        : MsgPort;
  171.     pad            : INTEGER;
  172.     segList        : SYS.BPTR;
  173.     stackSize      : LONGINT;
  174.     globVec        : APTR;
  175.     taskNum        : LONGINT;
  176.     stackBase      : SYS.BPTR;
  177.     result2        : LONGINT;
  178.     currentDir     : SYS.BPTR;
  179.     cis            : SYS.BPTR;
  180.     cos            : SYS.BPTR;
  181.     consoleTask    : APTR;
  182.     fileSystemTask : APTR;
  183.     cli            : SYS.BPTR;
  184.     returnAddr     : APTR;
  185.     pktWait        : APTR;
  186.     windowPtr      : APTR;
  187.     homeDir        : SYS.BPTR;
  188.     prFlags        : SET;
  189.     exitCode       : PROC;
  190.     exitData       : LONGINT;
  191.     arguments      : STRPTR;
  192.     localVars      : MinList;
  193.     shellPrivate   : LONGINT;
  194.     ces            : SYS.BPTR;
  195.   END;
  196.  
  197.   SemaphoreRequest = RECORD [1]
  198.     link    : MinNode;
  199.     waiter  : TaskPtr;
  200.   END;
  201.  
  202.   SignalSemaphorePtr = POINTER [1] TO SignalSemaphore;
  203.   SignalSemaphore = RECORD [1]
  204.     link          : Node;
  205.     nestCount     : INTEGER;
  206.     waitQueue     : MinList;
  207.     multipleLink  : SemaphoreRequest;
  208.     owner         : TaskPtr;
  209.     queueCount    : INTEGER;
  210.   END;
  211.  
  212.  
  213. (*-----------------------------------------------------------------------**
  214. **              System library bases used by this module.                **
  215. **-----------------------------------------------------------------------*)
  216.  
  217. CONST
  218.  
  219.   AbsExecBase = 4;
  220.  
  221. VAR
  222.  
  223.   SysBase  : ExecBasePtr;  (* Used to access exec.library functions *)
  224.  
  225.   mathBase : LibraryPtr;   (* Base pointer for math#?.library. This is
  226.                            ** used for all REAL arithmetic.
  227.                            *)
  228.  
  229.  
  230. (*-----------------------------------------------------------------------**
  231. ** These variables are used to remember the programs initial state, so   **
  232. ** that it can be restored on exit. Do NOT make them writeable.          **
  233. **-----------------------------------------------------------------------*)
  234.  
  235. VAR
  236.  
  237.   initialSP   : LONGINT;      (* Initial contents of A7. *)
  238.  
  239.  
  240. (*-----------------------------------------------------------------------**
  241. ** These variables are used to hold the arguments passed to the program  **
  242. ** by AmigaDOS or Workbench. Do NOT make them writeable.                 **
  243. **-----------------------------------------------------------------------*)
  244.  
  245. VAR
  246.  
  247.   fromWorkbench -: BOOLEAN;
  248.                            (* TRUE if the program was started from
  249.                            ** Workbench, FALSE if it was started by a
  250.                            ** Shell or CLI.
  251.                            *)
  252.  
  253.   dosCmdBuf     -: SYS.ADDRESS;
  254.                            (* When started from a Shell or CLI, this
  255.                            ** variable will hold the command line used to
  256.                            ** run the program. Only valid if
  257.                            ** fromWorkbench is FALSE.
  258.                            *)
  259.  
  260.   dosCmdLen     -: LONGINT;
  261.                            (* The length in characters of the command
  262.                            ** line. Only valid if fromWorkbench is FALSE.
  263.                            *)
  264.  
  265.   WBenchMsg     -: SYS.ADDRESS;
  266.                            (* The startup message sent to the program by
  267.                            ** Workbench. Only valid if fromWorkbench is
  268.                            ** TRUE. This must be cast to a
  269.                            ** Workbench.WBStartupPtr to gain access to
  270.                            ** the arguments.
  271.                            *)
  272.  
  273.  
  274. (*-----------------------------------------------------------------------**
  275. ** The following declarations are used by the memory allocator and the   **
  276. ** garbage collector. DO NOT CHANGE THEM. See Memory.txt for a           **
  277. ** discussion of their use.                                              **
  278. **-----------------------------------------------------------------------*)
  279.  
  280. <* IF DEBUG1 THEN *>
  281.   CONST
  282.     RecordBlkId = 052424C4BH; (* "RBLK" *)
  283.     ArrayBlkId  = 041424C4BH; (* "ABLK" *)
  284.     SysBlkId    = 053424C4BH; (* "SBLK" *)
  285. <* END *>
  286.  
  287. TYPE
  288.  
  289.   RecordBlkPtr = POINTER [1] TO RecordBlk;
  290.   RecordBlk = RECORD [1]
  291.     link : SYS.ADDRESS;
  292.     <* IF DEBUG1 THEN *>
  293.     id   : LONGINT;
  294.     <* END *>
  295.     tag  : SYS.TYPETAG;
  296.   END; (* RecordBlk *)
  297.  
  298.   ArrayBlkPtr = POINTER [1] TO ArrayBlk;
  299.   ArrayBlk = RECORD [1]
  300.     arrPos   : LONGINT;
  301.     elemSize : LONGINT;
  302.     size     : LONGINT;
  303.     link     : SYS.ADDRESS;
  304.     <* IF DEBUG1 THEN *>
  305.     id       : LONGINT;
  306.     <* END *>
  307.     tag      : SYS.TYPETAG;
  308.   END;
  309.  
  310.   SysBlkPtr = POINTER [1] TO SysBlk;
  311.   SysBlk = RECORD [1]
  312.     link : SYS.ADDRESS;
  313.     <* IF DEBUG1 THEN *>
  314.     id   : LONGINT;
  315.     <* END *>
  316.     size : LONGINT;
  317.   END; (* SysBlk *)
  318.  
  319.   MemBlockPtr = POINTER [1] TO MemBlock;
  320.   MemBlock = RECORD [1]
  321.     link    : MemBlockPtr;
  322.     <* IF DEBUG1 THEN *>
  323.     id      : LONGINT;
  324.     <* END *>
  325.     sizeTag : SET;
  326.   END;
  327.  
  328.   GCOffsetPtr = POINTER [1] TO GCOffsetBlock;
  329.   GCOffsetBlock = RECORD [1]
  330.     link     : GCOffsetPtr;
  331.     varBase,
  332.     offsets  : SYS.ADDRESS;
  333.   END; (* GCOffsetBlock *)
  334.  
  335.  
  336. (*-----------------------------------------------------------------------**
  337. ** The compiler uses the type descriptor for the following type when     **
  338. ** allocating arrays of pointers with NEW. This MUST be the first tagged **
  339. ** type declared in this module. It should also be the only one.         **
  340. **-----------------------------------------------------------------------*)
  341.  
  342. TYPE
  343.  
  344.   PointerDesc = RECORD
  345.     ptr : SYS.PTR
  346.   END; (* PointerDesc *)
  347.  
  348.  
  349. (*-----------------------------------------------------------------------**
  350. ** These variables are used by the memory allocator and the garbage      **
  351. ** collector.                                                            **
  352. **-----------------------------------------------------------------------*)
  353.  
  354. VAR
  355.  
  356.   gcBase   : SYS.ADDRESS;   (* The root of the list of variable offsets
  357.                             ** used by the mark phase of the garbage
  358.                             ** collector.
  359.                             *)
  360.  
  361.   traced   : SYS.ADDRESS;   (* The root of the list of traceable memory
  362.                             ** blocks. This list is scanned by the sweep
  363.                             ** phase of the garbage collector. This list
  364.                             ** can contain any type of block.
  365.                             *)
  366.  
  367.   untraced : SYS.ADDRESS;   (* The root of the list of untraced memory
  368.                             ** blocks. These blocks are ignored by the
  369.                             ** garbage collector. There should only be
  370.                             ** SysBlks in this list.
  371.                             *)
  372.  
  373. (*
  374.   memSem : SignalSemaphore; (* This semaphore is used to lock the
  375.                             ** global memory lists
  376.                             *)
  377. *)
  378.  
  379.  
  380. (*-----------------------------------------------------------------------**
  381. ** This variable holds a pointer to the program's Process structure.     **
  382. **-----------------------------------------------------------------------*)
  383.  
  384. VAR
  385.  
  386.   process : ProcessPtr;
  387.  
  388.  
  389. (*-----------------------------------------------------------------------**
  390. ** These are used to implement the automatic cleanup system.             **
  391. **-----------------------------------------------------------------------*)
  392.  
  393. TYPE
  394.  
  395.   CleanupProc * = PROCEDURE (VAR rc : LONGINT);
  396.  
  397.   CleanupPtr = POINTER [1] TO CleanupRec;
  398.   CleanupRec = RECORD [1]
  399.     link : CleanupPtr;
  400.     proc : CleanupProc;
  401.   END; (* CleanupRec *)
  402.  
  403.  
  404. VAR
  405.  
  406.   cleanupList : CleanupPtr;
  407.  
  408.  
  409. (*-----------------------------------------------------------------------**
  410. ** Variables used to install and remove a trap handler.                  **
  411. **-----------------------------------------------------------------------*)
  412.  
  413. VAR
  414.  
  415.   userTraps   : SET;        (* The user traps allocated for the program. *)
  416.   handlerInstalled : BOOLEAN; (* Is the handler installed? *)
  417.   oldTrapCode : PROC;        (* The initial trap handler. *)
  418.   oldTrapData : SYS.ADDRESS; (* The initial trap data. *)
  419.  
  420.  
  421. (*-----------------------------------------------------------------------**
  422. ** Variables used to report the position of errors.                      **
  423. **-----------------------------------------------------------------------*)
  424.  
  425. VAR
  426.  
  427.   errModule -: ARRAY 32 OF CHAR;
  428.   errLine   -: INTEGER;
  429.   errCol    -: INTEGER;
  430.  
  431.  
  432. (*-----------------------------------------------------------------------**
  433. ** Declarations used to register and track modules, types and commands.  **
  434. **-----------------------------------------------------------------------*)
  435.  
  436. TYPE
  437.  
  438.   RegNode *= POINTER [1] TO RegisterDesc;
  439.   RegisterDesc = RECORD [1]
  440.     next -: RegNode;
  441.     name -: ARRAY 32 OF CHAR;
  442.   END; (* RegisterDesc *)
  443.  
  444.   Module *= POINTER [1] TO ModuleDesc;
  445.   ModuleDesc *= RECORD [1] (RegisterDesc)
  446.     types    -: RegNode;
  447.     commands -: RegNode;
  448.   END; (* ModuleDesc *)
  449.  
  450.   Type *= POINTER [1] TO TypeDesc;
  451.   TypeDesc *= RECORD [1] (RegisterDesc)
  452.     tag -: SYS.TYPETAG;
  453.   END; (* TypeDesc *)
  454.  
  455.   CommandProc *= PROCEDURE;
  456.   Command *= POINTER [1] TO CommandDesc;
  457.   CommandDesc *= RECORD [1] (RegisterDesc)
  458.     proc -: CommandProc;
  459.   END; (* CommandDesc *)
  460.  
  461. VAR
  462.  
  463.   modules -: RegNode;
  464.  
  465.  
  466. (*-----------------------------------------------------------------------**
  467. ** Finalization procedure types                                          **
  468. **-----------------------------------------------------------------------*)
  469.  
  470. TYPE
  471.  
  472.   Finalizer *= PROCEDURE (obj : SYS.PTR);
  473.   StructFinalizer *= PROCEDURE (str : SYS.ADDRESS);
  474.  
  475.  
  476. (*-----------------------------------------------------------------------**
  477. ** Structure attached to Task.userData                                   **
  478. **-----------------------------------------------------------------------*)
  479.  
  480. TYPE
  481.  
  482.   UserDataPtr *= POINTER [1] TO UserData;
  483.   UserData *= RECORD [1]
  484.     userData * : APTR;
  485.     dataSegment * : APTR;
  486.   END; (* UserData *)
  487.  
  488. VAR
  489.  
  490.   userData : UserData;
  491.  
  492.   memSem : SignalSemaphore; (* This semaphore is used to lock the
  493.                             ** global memory lists
  494.                             *)
  495.  
  496. (*-----------------------------------------------------------------------**
  497. ** Exec library functions used by this module. Note that the parameter   **
  498. ** and return types do not exactly match the declarations in module      **
  499. ** Exec.                                                                 **
  500. **-----------------------------------------------------------------------*)
  501.  
  502.  
  503. PROCEDURE Forbid [SysBase,-132] ();
  504. PROCEDURE AllocMem [SysBase,-198]
  505.   ( byteSize     [0] : LONGINT;
  506.     requirements [1] : SET )
  507.   : SYS.ADDRESS;
  508. PROCEDURE FreeMem [SysBase,-210]
  509.   ( memoryBlock [9] : SYS.ADDRESS;
  510.     byteSize    [0] : LONGINT );
  511. PROCEDURE FindTask [SysBase,-294]
  512.   ( name [9] : STRPTR )
  513.   : TaskPtr;
  514. PROCEDURE AllocTrap [SysBase,-342]
  515.   ( trapNum [0] : LONGINT )
  516.   : SHORTINT;
  517. PROCEDURE FreeTrap [SysBase,-348]
  518.   ( trapNum [0] : LONGINT );
  519. PROCEDURE GetMsg [SysBase,-372]
  520.   ( VAR port [8] : MsgPort )
  521.   : SYS.ADDRESS;
  522. PROCEDURE ReplyMsg [SysBase,-378]
  523.   ( message [9] : SYS.ADDRESS );
  524. PROCEDURE WaitPort [SysBase,-384]
  525.   ( VAR port [8] : MsgPort );
  526. PROCEDURE OpenLibrary [SysBase,-552]
  527.   ( libName [9] : ARRAY OF CHAR;
  528.     version [0] : LONGINT )
  529.   : LibraryPtr;
  530. PROCEDURE InitSemaphore [SysBase,-558]
  531.   ( VAR sigSem [8] : SignalSemaphore );
  532. PROCEDURE ObtainSemaphore [SysBase,-564]
  533.   ( VAR sigSem [8] : SignalSemaphore );
  534. PROCEDURE ReleaseSemaphore [SysBase,-570]
  535.   ( VAR sigSem [8] : SignalSemaphore );
  536. PROCEDURE CopyMem [SysBase,-624]
  537.   ( source [8] : LONGINT;
  538.     dest   [9] : LONGINT;
  539.     size   [0] : LONGINT );
  540.  
  541.  
  542. (*-----------------------------------------------------------------------*)
  543.  
  544.  
  545. (* FreeMemBlock() returns a block of memory to the system. It determines
  546. ** the type of block by inspecting the type bits in the size/tag
  547. ** longword.
  548. *)
  549.  
  550. PROCEDURE FreeMemBlock ( mem : MemBlockPtr );
  551.  
  552.   VAR size : LONGINT; sizeTag : SET;
  553.  
  554. BEGIN (* FreeMemBlock *)
  555.   sizeTag := mem.sizeTag;
  556.   (* Clearing bit 31 in sizeTag allows this procedure to work even if
  557.   ** the program halts during the mark phase of the garbage collector.
  558.   *)
  559.   EXCL (sizeTag, 31);
  560.   IF 0 IN sizeTag THEN (* SysBlk *)
  561.     size := SYS.VAL (LONGINT, sizeTag) - 1;
  562.     INC (size, SIZE (SysBlk))
  563.   ELSIF 1 IN sizeTag THEN (* ArrayBlk *)
  564.     DEC (SYS.VAL (LONGINT, mem), 12);
  565.     SYS.GET (SYS.VAL (LONGINT, mem) + 8, size);
  566.     INC (size, SIZE (ArrayBlk))
  567.   ELSE (* RecordBlk *)
  568.     SYS.GET (SYS.VAL (LONGINT, sizeTag), size);
  569.     INC (size, SIZE (RecordBlk))
  570.   END;
  571.   FreeMem (mem, size);
  572. END FreeMemBlock;
  573.  
  574.  
  575. (* DoCleanup is responsible for any cleanup required before exiting the
  576. ** program. It is called by Halt() and TrapHandler().
  577. *)
  578.  
  579. PROCEDURE* DoCleanup
  580.   ( rc : LONGINT; module : STRPTR; pos : LONGINT );
  581.  
  582.   VAR mem, next : MemBlockPtr; cleanupPtr : CleanupPtr; t : LONGINT;
  583.  
  584. BEGIN (* DoCleanup *)
  585.   IF module # NIL THEN
  586.     COPY (module^, errModule);
  587.     errLine := SHORT (pos DIV 10000H); errCol := SHORT (pos MOD 10000H)
  588.   ELSE
  589.     errModule := ""; errLine := 0; errCol := 0
  590.   END;
  591.  
  592.   (* Execute any installed cleanup procedures. *)
  593.  
  594.   cleanupPtr := cleanupList;
  595.   cleanupList := NIL; (* This avoids loops if an error occurs in a
  596.                       ** cleanup procedure.
  597.                       *)
  598.   WHILE cleanupPtr # NIL DO
  599.     cleanupPtr.proc (rc);
  600.     cleanupPtr := cleanupPtr.link
  601.   END;
  602.  
  603.   (* Free all memory allocated by the program. This must be done *after*
  604.   ** any cleanup procedures, in case they allocate memory.
  605.   *)
  606.  
  607.   ObtainSemaphore(memSem);
  608.   mem := traced; traced := NIL;
  609.   WHILE mem # NIL DO
  610.     next := mem.link;
  611.     FreeMemBlock (mem);
  612.     mem := next;
  613.   END;
  614.  
  615.   mem := untraced; untraced := NIL;
  616.   WHILE mem # NIL DO
  617.     next := mem.link;
  618.     FreeMemBlock (mem);
  619.     mem := next;
  620.   END;
  621.   ReleaseSemaphore(memSem);
  622.  
  623.   (* This is the *last* code executed by the program. *)
  624.  
  625.   IF fromWorkbench THEN
  626.     Forbid;              (* Stops AmigaDOS from unloading us *)
  627.     ReplyMsg (WBenchMsg) (* Tells Workbench to do it instead *)
  628.   END;
  629.  
  630.   SYS.SETREG (0, rc)             (* Sets return code for Dos *)
  631. END DoCleanup;
  632.  
  633.  
  634. (*-----------------------------------------------------------------------**
  635. ** The following procedures are known to the compiler. DO NOT RENAME OR  **
  636. ** REMOVE THEM. They should not be exported, but must be marked as       **
  637. ** assignable or the LongVars+ pragma switched on so that they can       **
  638. ** access global variables.                                              **
  639. **-----------------------------------------------------------------------*)
  640.  
  641.  
  642. (* Linker Symbol: "Kernel_Halt"
  643. **
  644. ** This procedure is called as the result of a HALT or ASSERT statement,
  645. ** and also when the program exits normally by reaching the END in the
  646. ** main body of the main module. The return code is passed in register D0.
  647. **
  648. ** Halt restores the stack pointer to the value held in the initialSP
  649. ** variable. As a result, it must not declare any local variables.
  650. **
  651. ** The LongVars pragma is used to stop the compiler loading the module's
  652. ** global variable base into A4. As a consequence, DoCleanup() must be
  653. ** declared as PROCEDURE* (ie - assignable) so that it can access global
  654. ** variables.
  655. *)
  656.  
  657. <*$ < LongVars+ *>
  658. PROCEDURE Halt;
  659.  
  660. BEGIN (* Halt *)
  661.   (* Restore initial stack pointer. *)
  662.   SYS.SETREG (15, initialSP);
  663.   (* Do any remaining cleanup. *)
  664.   DoCleanup (SYS.REG (0), SYS.VAL (STRPTR, SYS.REG (8)), SYS.REG (1));
  665. END Halt;
  666. <*$ > *>
  667.  
  668.  
  669. (* Linker symbol : Kernel_NewRecord
  670. **
  671. ** NewRecord() is called by the compiler to implement a NEW call, when
  672. ** the parameter is a POINTER TO RECORD type.
  673. **
  674. ** The parameter is the address of the type descriptor of the RECORD
  675. ** type.
  676. *)
  677.  
  678. PROCEDURE* NewRecord ( tag : SYS.TYPETAG ) : SYS.PTR;
  679.  
  680.   VAR
  681.     memBlock : RecordBlkPtr; (* Points to the allocated memory. *)
  682.     size : LONGINT;
  683.  
  684. <*$ReturnChk-*>
  685. BEGIN (* NewRecord *)
  686.   ASSERT (tag # NIL, preCondition);
  687.   SYS.GET (SYS.VAL (LONGINT, tag), size);
  688.   ASSERT (size >= 0, invariant);
  689.   memBlock := AllocMem (size + SIZE (RecordBlk), {memClear});
  690.   IF memBlock # NIL THEN
  691.     memBlock.tag := tag;
  692.     <* IF DEBUG1 THEN *>
  693.     memBlock.id := RecordBlkId;
  694.     <* END *>
  695.     ObtainSemaphore(memSem);
  696.     memBlock.link := traced; traced := memBlock;
  697.     INC (SYS.VAL (LONGINT, memBlock), SIZE (RecordBlk));
  698.     ReleaseSemaphore(memSem);
  699.   END;
  700.   RETURN SYS.VAL (SYS.PTR, memBlock)
  701. END NewRecord;
  702.  
  703.  
  704. (* Linker symbol : Kernel_NewArray
  705. **
  706. ** NewArray() is called by the compiler to implement a NEW call, when the
  707. ** parameter is a POINTER TO ARRAY OF RECORD type.
  708. **
  709. ** The tag parameter is the address of the type descriptor of the RECORD
  710. ** type. The size parameter is the total size of the array, calculated
  711. ** inline by the compiler.
  712. *)
  713.  
  714. PROCEDURE* NewArray ( tag : SYS.TYPETAG; size : LONGINT ) : SYS.PTR;
  715.  
  716.   VAR memBlock : ArrayBlkPtr; (* Points to the allocated memory. *)
  717.  
  718. <*$ReturnChk-*>
  719. BEGIN (* NewArray *)
  720.   ASSERT (tag # NIL, preCondition);
  721.   ASSERT (size >= 0, preCondition);
  722.   memBlock := AllocMem (size + SIZE (ArrayBlk), {memClear});
  723.   IF memBlock # NIL THEN
  724.     memBlock.tag := SYS.VAL (SYS.TYPETAG, SYS.VAL (LONGINT, tag) + 2);
  725.     SYS.GET (SYS.VAL (LONGINT, tag), memBlock.elemSize);
  726.     memBlock.size := size;
  727.     <* IF DEBUG1 THEN *>
  728.     memBlock.id := ArrayBlkId;
  729.     <* END *>
  730.     ObtainSemaphore(memSem);
  731.     memBlock.link := traced; traced := SYS.ADR (memBlock.link);
  732.     INC (SYS.VAL (LONGINT, memBlock), SIZE (ArrayBlk));
  733.     ReleaseSemaphore(memSem);
  734.   END;
  735.   RETURN SYS.VAL (SYS.PTR, memBlock)
  736. END NewArray;
  737.  
  738.  
  739. (* Linker symbol: Kernel_NewSysBlk
  740. **
  741. ** NewSysBlk() is called by the compiler to implement a NEW or SYSTEM.NEW
  742. ** call, when an untyped memory block is required.
  743. **
  744. ** The size parameter is the number of bytes required, and the isTraced
  745. ** parameter determines which memory list the chunk is to be linked to.
  746. *)
  747.  
  748. PROCEDURE* NewSysBlk ( size : LONGINT; isTraced : BOOLEAN )
  749.   : SYS.ADDRESS;
  750.  
  751.   VAR memBlock : SysBlkPtr; (* Points to the allocated memory. *)
  752.  
  753. <*$ReturnChk-*>
  754. BEGIN (* NewSysBlk *)
  755.   ASSERT (size > 0, preCondition);
  756.   (* Round size up to next multiple of 4 -- VERY IMPORTANT *)
  757.   size := SYS.AND (size + 3, 0FFFFFFFCH);
  758.   memBlock := AllocMem (size + SIZE (SysBlk), {memClear});
  759.   IF memBlock # NIL THEN
  760.     memBlock.size := size + 1;
  761.     <* IF DEBUG1 THEN *>
  762.     memBlock.id := SysBlkId;
  763.     <* END *>
  764.     ObtainSemaphore(memSem);
  765.     IF isTraced THEN memBlock.link := traced; traced := memBlock
  766.     ELSE memBlock.link := untraced; untraced := memBlock;
  767.     END;
  768.     INC (SYS.VAL (LONGINT, memBlock), SIZE (SysBlk));
  769.     ReleaseSemaphore(memSem);
  770.   END;
  771.   RETURN memBlock
  772. END NewSysBlk;
  773.  
  774.  
  775. (* Linker symbol: Kernel_Dispose
  776. **
  777. ** Dispose() is called by the compiler to implement a SYSTEM.DISPOSE
  778. ** call.
  779. **
  780. ** The parameter is the address of the variable to be freed. The untraced
  781. ** and traced memory lists are searched first to determine if the
  782. ** variable points to a memory block that has been allocated by the
  783. ** program. If not, the program is HALTed with a return code of 21.
  784. *)
  785.  
  786. PROCEDURE Dispose* ( VAR adr : SYS.ADDRESS );
  787.  
  788.   VAR mem, last, next : MemBlockPtr; size : LONGINT;
  789.  
  790. BEGIN (* Dispose *)
  791.   mem := adr;
  792.   IF mem # NIL THEN
  793.     DEC (SYS.VAL (LONGINT, mem), SIZE (MemBlock));
  794.     ObtainSemaphore(memSem);
  795.     last := SYS.ADR (untraced); next := untraced;
  796.     WHILE (next # NIL) & (next # mem) DO
  797.       last := next; next := next.link
  798.     END;
  799.     IF next = NIL THEN
  800.       last := SYS.ADR (traced); next := traced;
  801.       WHILE (next # NIL) & (next # mem) DO
  802.         last := next; next := next.link
  803.       END;
  804.       IF next = NIL THEN HALT (notAllocated) END
  805.     END;
  806.     last.link := next.link;
  807.     ReleaseSemaphore(memSem);
  808.     FreeMemBlock (mem);
  809.     adr := NIL
  810.   END
  811. END Dispose;
  812.  
  813.  
  814. (* Linker symbol : Kernel_InitGC
  815. **
  816. ** InitGC() links a module's GC offset block into a global list, which is
  817. ** traversed by the mark phase of the garbage collector. It is called
  818. ** invisibly in the module's initialisation code if it has any global
  819. ** traced pointers.
  820. *)
  821.  
  822. <*$ < LongVars+ NilChk- *>
  823. PROCEDURE* InitGC ( varBase, offsets : SYS.ADDRESS );
  824.  
  825.   VAR newGC : GCOffsetPtr;
  826.  
  827. BEGIN (* InitGC *)
  828.   newGC := NewSysBlk (SIZE (GCOffsetBlock), FALSE);
  829.   ASSERT (newGC # NIL, outOfMem);
  830.   newGC.link := gcBase; gcBase := newGC;
  831.   newGC.varBase := varBase; newGC.offsets := offsets
  832. END InitGC;
  833. <*$ > *>
  834.  
  835.  
  836. (* Linker symbol : Kernel_Move
  837. **
  838. ** This procedure implements the SYSTEM.MOVE procedure.
  839. *)
  840.  
  841. <*$ < LongVars+ NilChk- *>
  842. PROCEDURE Move ( src, dst, len : LONGINT );
  843.  
  844.   VAR byte : SYS.BYTE;
  845.  
  846. BEGIN (* Move *)
  847.   IF (src # dst) & (len > 0) THEN
  848.     IF (dst > src) & (dst < (src + len)) THEN
  849.       (* The blocks overlap, copy bytes from the *top* down *)
  850.       INC (src, len); INC (dst, len);
  851.       REPEAT
  852.         DEC (src); DEC (dst);
  853.         SYS.GET (src, byte); SYS.PUT (dst, byte);
  854.         DEC (len)
  855.       UNTIL len = 0
  856.     ELSIF (src > dst) & (src < (dst + len)) THEN
  857.       (* The blocks overlap, copy bytes from the *bottom* up *)
  858.       REPEAT
  859.         SYS.GET (src, byte); SYS.PUT (dst, byte);
  860.         INC (src); INC (dst);
  861.         DEC (len)
  862.       UNTIL len = 0
  863.     ELSE
  864.       (* Non-overlapping blocks, let CopyMem() do it. *)
  865.       CopyMem (src, dst, len)
  866.     END;
  867.   END
  868. END Move;
  869. <*$ > *>
  870.  
  871.  
  872. (* Linker symbol : Kernel_StackChk
  873. **
  874. ** This procedure implements stack checking for the compiler. The size of
  875. ** the additional stack required is passed in register D0.
  876. *)
  877.  
  878. <*$ < LongVars+ EntryExitCode- *> (* Stack pragma state *)
  879. PROCEDURE StackChk;
  880. BEGIN (* StackChk *)
  881.   SYS.INLINE (02F08H);    (*    MOVE.L A0, -(A7)    *)
  882.   SYS.SETREG (8,SysBase); (*    MOVE.L SysBase,A0   *)
  883.   SYS.INLINE (
  884.     02068H, 00114H,       (*    MOVE.L 0114(A0), A0 *)
  885.     02068H, 0003AH,       (*    MOVE.L 003A(A0), A0 *)
  886.     -2E40H,               (*    ADD.L  D0, A0       *)
  887.     041E8H, 1500,         (*    LEA    1500(A0), A0 *)
  888.     -4E31H,               (*    CMPA.L A7,  A0      *)
  889.     0630AH,               (*    BLS    1$           *)
  890.     04E45H,               (*    TRAP   #5           *)
  891.     0,0,                  (*    DC.L   moduleName   *)
  892.     0,                    (*    DC.W   line         *)
  893.     0,                    (*    DC.W   col          *)
  894.     0205FH,               (* 1$ MOVE.L (A7)+, A0    *)
  895.     04E75H                (*    RTS                 *)
  896.   ); (* INLINE *)
  897. END StackChk;
  898. <*$ > *> (* Unstack pragmas *)
  899.  
  900.  
  901. (*-----------------------------------------------------------------------**
  902. ** The following procedures implement REAL arithmetic. They are known to **
  903. ** the compiler and MUST NOT BE REMOVED OR RENAMED. They receive their   **
  904. ** parameters in registers. They should not be exported, or marked as    **
  905. ** assignable.                                                           **
  906. **                                                                       **
  907. ** The REAL math routines access the mathBase variable using long        **
  908. ** addressing for efficiency. The compiler places the arguments in the   **
  909. ** appropriate registers before calling them. These are really just      **
  910. ** stubs that are used to remove the need for the compiler to know       **
  911. ** about the mathBase variable. They use JMP instead of JSR for the call **
  912. ** to save one RTS: the library function will return direct to the       **
  913. ** calling code instead of here.                                         **
  914. **-----------------------------------------------------------------------*)
  915.  
  916. <*$ < LongVars+ *> (* Stack pragma state *)
  917.  
  918. PROCEDURE SPFix;
  919. (* It appears to be a "feature" of the Commodore math libraries that the
  920. ** *Fix functions behave differently when used on machines with and without
  921. ** hardware FPUs. Sometimes it truncates, sometimes it rounds. Since *Fix
  922. ** cannot be relied on to truncate the result, we must do it ourselves.
  923. *)
  924.  
  925. <*$EntryExitCode-*>
  926. BEGIN (* SPFix *)
  927.   SYS.INLINE (02F00H);                      (*    MOVE.L  D0,-(A7)       *)
  928.   SYS.SETREG (14, mathBase);                (*    MOVEA.L mathBase,A6    *)
  929.   SYS.SETREG (1, SYS.REG (0));              (*    MOVE.L  D0,D1          *)
  930.   SYS.INLINE (4EAEH,-48);                   (*    JSR     LVOSPTst(A6)   *)
  931.   SYS.INLINE (06C08H);                      (*    BGE     1$             *)
  932.   SYS.INLINE (0201FH);                      (*    MOVE.L  (A7)+,D0       *)
  933.   SYS.INLINE (4EAEH,-96);                   (*    JSR     LVOSPCeil(A6)  *)
  934.   SYS.INLINE (06006H);                      (*    BRA.S   2$             *)
  935.   SYS.INLINE (0201FH);                      (* 1$ MOVE.L  (A7)+,D0       *)
  936.   SYS.INLINE (4EAEH,-90);                   (*    JSR     LVOSPFloor(A6) *)
  937.   SYS.INLINE (4EEEH,-30);                   (* 2$ JMP     LVOSPFix(A6)   *)
  938. END SPFix;
  939.  
  940. PROCEDURE SPFlt;
  941. <*$EntryExitCode-*>
  942. BEGIN (* SPFlt *)
  943.   SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  944.   SYS.INLINE (4EEEH,-36);                        (* JMP     LVOSPFlt(A6) *)
  945. END SPFlt;
  946.  
  947. PROCEDURE SPCmp;
  948. <*$EntryExitCode-*>
  949. BEGIN (* SPCmp *)
  950.   SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  951.   SYS.INLINE (4EEEH,-42);                        (* JMP     LVOSPCmp(A6) *)
  952. END SPCmp;
  953.  
  954. (* REAL is now IEEE single-precision, so this doesn't happen.
  955. PROCEDURE SPTst;
  956. (* MathFFP.SPTst takes its parameter in D1 instead of D0 as you would
  957. ** expect. To avoid complicating matters, the compiler passes the parameter
  958. ** in D0 anyway, and the stub copies it to D1.
  959. *)
  960.  
  961. <*$EntryExitCode-*>
  962. BEGIN (* SPTst *)
  963.   SYS.SETREG (1, SYS.REG (0));                   (* MOVE.L  D0,D1        *)
  964.   SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  965.   SYS.INLINE (4EEEH,-48);                        (* JMP     LVOSPTst(A6) *)
  966. END SPTst;
  967. *)
  968.  
  969. PROCEDURE SPTst;
  970.  
  971. <*$EntryExitCode-*>
  972. BEGIN (* SPTst *)
  973.   SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  974.   SYS.INLINE (4EEEH,-48);                        (* JMP     LVOSPTst(A6) *)
  975. END SPTst;
  976.  
  977. PROCEDURE SPAbs;
  978. <*$EntryExitCode-*>
  979. BEGIN (* SPAbs *)
  980.   SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  981.   SYS.INLINE (4EEEH,-54);                        (* JMP     LVOSPAbs(A6) *)
  982. END SPAbs;
  983.  
  984. PROCEDURE SPNeg;
  985. <*$EntryExitCode-*>
  986. BEGIN (* SPNeg *)
  987.   SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  988.   SYS.INLINE (4EEEH,-60);                        (* JMP     LVOSPNeg(A6) *)
  989. END SPNeg;
  990.  
  991. PROCEDURE SPAdd;
  992. <*$EntryExitCode-*>
  993. BEGIN (* SPAdd *)
  994.   SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  995.   SYS.INLINE (4EEEH,-66);                        (* JMP     LVOSPAdd(A6) *)
  996. END SPAdd;
  997.  
  998. PROCEDURE SPSub;
  999. <*$EntryExitCode-*>
  1000. BEGIN (* SPSub *)
  1001.   SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  1002.   SYS.INLINE (4EEEH,-72);                        (* JMP     LVOSPSub(A6) *)
  1003. END SPSub;
  1004.  
  1005. PROCEDURE SPMul;
  1006. <*$EntryExitCode-*>
  1007. BEGIN (* SPMul *)
  1008.   SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  1009.   SYS.INLINE (4EEEH,-78);                        (* JMP     LVOSPMul(A6) *)
  1010. END SPMul;
  1011.  
  1012. PROCEDURE SPDiv;
  1013. <*$EntryExitCode-*>
  1014. BEGIN (* SPDiv *)
  1015.   SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  1016.   SYS.INLINE (4EEEH,-84);                        (* JMP     LVOSPDiv(A6) *)
  1017. END SPDiv;
  1018.  
  1019. <*$ > *> (* Unstack pragmas *)
  1020.  
  1021.  
  1022. (*-----------------------------------------------------------------------**
  1023. ** Multiplication and division of 32-bit integers is done in software,   **
  1024. ** in the abscence of appropriate instructions for the MC68000 CPU. The  **
  1025. ** procedures that perform this task are too large to be coded inline,   **
  1026. ** so they are assembled seperately to the object file "LMath.o",        **
  1027. ** which is listed as an external library in the module header. See      **
  1028. ** "LMath.asm" for the source code. The external declarations for these  **
  1029. ** procedures are given below, purely for reference.                     **
  1030. **-----------------------------------------------------------------------*)
  1031.  
  1032.  
  1033. PROCEDURE [4] Mul32 ["Kernel_Mul32"] (l1 [0], l2 [1] : LONGINT) : LONGINT;
  1034.  
  1035. PROCEDURE [4] Div32 ["Kernel_Div32"] (l1 [0], l2 [1] : LONGINT) : LONGINT;
  1036.  
  1037.  
  1038. (*-----------------------------------------------------------------------**
  1039. ** Procedures declared after this point are not known to the compiler.   **
  1040. **-----------------------------------------------------------------------*)
  1041.  
  1042.  
  1043. (* TrapHandler() is installed in the tcTrapCode field of the process
  1044. ** structure by InstallTrapHandler(). Its job is to deal with any processor
  1045. ** traps generated by the program. It is executed in supervisor mode, so it
  1046. ** must do its job as quickly as possible, then get out of supervisor mode
  1047. ** using an RTE instruction.
  1048. **
  1049. ** The stack looks like this when TrapHandler() is called:
  1050. **
  1051. **   6(SP) - (LONG) PC when trap occurred
  1052. **   4(SP) - (WORD) SR when trap occurred
  1053. **   0(SP) - (LONG) Trap #
  1054. **
  1055. ** This procedure should only concern itself with traps that are known
  1056. ** to be generated by Oberon-A programs. These are traps 2..8, 10..11 and
  1057. ** 32..38 (user traps 0..6). Anything else should be propagated to the
  1058. ** trap handler stored in oldTrapCode.
  1059. *)
  1060.  
  1061. PROCEDURE* TrapHandler;
  1062.  
  1063. <*$ < EntryExitCode- LongVars+*>
  1064. BEGIN (* TrapHandler *)
  1065.   (* Check if the trap is ours to handle *)
  1066.   SYS.INLINE (00C97H,0,9);        (*    CMP.L  #9,(A7)         *)
  1067.   SYS.INLINE (06772H);            (*    BEQ.S  1$              *)
  1068.   SYS.INLINE (00C97H,0,2);        (*    CMP.L  #2,(A7)         *)
  1069.   SYS.INLINE (0656AH);            (*    BLO.S  1$              *)
  1070.   SYS.INLINE (00C97H,0,11);       (*    CMP.L  #11,(A7)        *)
  1071.   SYS.INLINE (06310H);            (*    BLS.S  2$              *)
  1072.   SYS.INLINE (00C97H,0,32);       (*    CMP.L  #32,(A7)        *)
  1073.   SYS.INLINE (0655AH);            (*    BLO.S  1$              *)
  1074.   SYS.INLINE (00C97H,0,38);       (*    CMP.L  #38,(A7)        *)
  1075.   SYS.INLINE (06252H);            (*    BHI.S  1$              *)
  1076.  
  1077.   (* It's ours *)
  1078.   (* Pop the trap number off the stack. *)
  1079.   SYS.INLINE (201FH);             (* 2$ MOVE.L (A7)+,D0        *)
  1080.  
  1081.   (* IF trapno IN {CHK,TRAPV,32..38}) THEN *)
  1082.   SYS.INLINE (00C80H,0,6);        (*    CMP.L  #6,D0           *)
  1083.   SYS.INLINE (06724H);            (*    BEQ.S  4$              *)
  1084.   SYS.INLINE (00C80H,0,7);        (*    CMP.L  #7,D0           *)
  1085.   SYS.INLINE (0671CH);            (*    BEQ.S  4$              *)
  1086.   SYS.INLINE (00C80H,0,32);       (*    CMP.L  #32,D0          *)
  1087.   SYS.INLINE (06522H);            (*    BLO.S  5$              *)
  1088.   SYS.INLINE (00C80H,0,38);       (*    CMP.L  #38,D0          *)
  1089.   SYS.INLINE (0621AH);            (*    BHI.S  5$              *)
  1090.  
  1091.   (* Get the module name and source code position. These are
  1092.   ** embedded in the object code by the compiler, immediately
  1093.   ** after the trap instruction. There is an additional short
  1094.   ** branch directly after a CHK or TRAPV instruction.
  1095.   *)
  1096.  
  1097.   SYS.INLINE (0226FH,2);          (*    MOVE.L 2(A7),A1        *)
  1098.   SYS.INLINE (02051H);            (*    MOVE.L (A1),A0         *)
  1099.   SYS.INLINE (02229H,4);          (*    MOVE.L 4(A1),D1        *)
  1100.   SYS.INLINE (6012H);             (*    BRA.S  $6              *)
  1101.  
  1102.   SYS.INLINE (0226FH,2);          (* 4$ MOVE.L 2(A7),A1        *)
  1103.   SYS.INLINE (02069H,2);          (*    MOVE.L 2(A1),A0        *)
  1104.   SYS.INLINE (02229H,6);          (*    MOVE.L 6(A1),D1        *)
  1105.   SYS.INLINE (6004H);             (*    BRA.S  $6              *)
  1106.  
  1107.   (* ELSE *)
  1108.   SYS.INLINE (-6E38H);            (* 5$ SUBA.L A0,A0           *)
  1109.   SYS.INLINE (07200H);            (*    MOVEQ  #0,D1           *)
  1110.  
  1111.   (* Add 100 to the trap number *)
  1112.   SYS.INLINE (0680H,0,100);       (* 6$ ADDI.L #100,D0         *)
  1113.  
  1114.   (* Replace the old PC with the address of Halt() *)
  1115.   SYS.SETREG (9, Halt);           (*    MOVE.L #Kernel_Halt,A1 *)
  1116.   SYS.INLINE (2F49H,2);           (*    MOVE.L A1,2(A7)        *)
  1117.  
  1118.   (* Call Halt() *)
  1119.   SYS.INLINE (4E73H);             (*    RTE                    *)
  1120.  
  1121.   (* Never seen it before in my life, y'honour *)
  1122.   SYS.SETREG (0, oldTrapCode);    (* 1$ MOVE.L oldTrapCode,D0  *)
  1123.   SYS.INLINE (06704H);            (*    BEQ.S  3$              *)
  1124.   SYS.INLINE (02F00H);            (*    MOVE.L D0,-(A7)        *)
  1125.   SYS.INLINE (04E75H);            (*    RTS                    *)
  1126.   SYS.INLINE (0588FH);            (* 3$ ADDQ.L #4,A7           *)
  1127.   SYS.INLINE (04E73H);            (*    RTE                    *)
  1128. END TrapHandler;
  1129. <*$ > *>
  1130.  
  1131. (* SetCleanup() installs a procedure that will be executed automatically
  1132. ** when the program exits.
  1133. *)
  1134.  
  1135. PROCEDURE SetCleanup * ( proc : CleanupProc );
  1136.  
  1137.   VAR newCleanup : CleanupPtr;
  1138.  
  1139. BEGIN (* SetCleanup *)
  1140.   newCleanup := NewSysBlk (SIZE (CleanupRec), FALSE);
  1141.   ASSERT (newCleanup # NIL, outOfMem);
  1142.   newCleanup.link := cleanupList; cleanupList := newCleanup;
  1143.   newCleanup.proc := proc
  1144. END SetCleanup;
  1145.  
  1146.  
  1147. (* Size() returns the size in bytes of the record type whose type tag
  1148. ** is passed as a parameter. The type tag is obtained by a call to
  1149. ** SYSTEM.TAG.
  1150. *)
  1151.  
  1152. <*$ < LongVars+ *> (* No global variables used *)
  1153. PROCEDURE Size * ( type : SYS.TYPETAG ) : LONGINT;
  1154.  
  1155.   VAR size : LONGINT;
  1156.  
  1157. BEGIN (* Size *)
  1158.   ASSERT (type # NIL, preCondition);
  1159.   SYS.GET (SYS.VAL (LONGINT, type), size);
  1160.   RETURN size
  1161. END Size;
  1162. <*$ > *>
  1163.  
  1164.  
  1165. (* Name() copies the name of the type whose type tag is passed as a
  1166. ** parameter into a string variable. The type tag is obtained by a call to
  1167. ** SYSTEM.TAG.
  1168. **
  1169. ** This procedure relies on the type tag being a pointer to a valid type
  1170. ** descriptor, which has the following structure:
  1171. **
  1172. **   TypeDesc = RECORD
  1173. **     size        : LONGINT;
  1174. **     tagTable    : ARRAY 16 OF SYSTEM.TYPETAG;
  1175. **     offsetTable : ARRAY numOffsets OF LONGINT;
  1176. **     name        : ARRAY nameLen+1 OF CHAR;
  1177. **   END;
  1178. **
  1179. ** The offsetTable array is terminated by a negative offset, which this
  1180. ** procedure uses to find the start of the name field.
  1181. *)
  1182.  
  1183. <*$ < LongVars+ *> (* No global variables used *)
  1184. PROCEDURE Name * ( type : SYS.TYPETAG; VAR buf : ARRAY OF CHAR );
  1185.  
  1186.   VAR name : STRPTR; offset : LONGINT;
  1187.  
  1188. BEGIN (* Name *)
  1189.   ASSERT (type # NIL, preCondition);
  1190.   (* Point name at the start of the offsetTable field. *)
  1191.   name := SYS.VAL (STRPTR, SYS.VAL (LONGINT, type) + 68);
  1192.   (* Scan offsetTable until a negative offset is found *)
  1193.   REPEAT
  1194.     SYS.GET (name, offset);
  1195.     INC (SYS.VAL (LONGINT, name), 4);
  1196.   UNTIL offset < 0;
  1197.   (* name now points to the name field. *)
  1198.   COPY (name^, buf)
  1199. END Name;
  1200. <*$ > *>
  1201.  
  1202.  
  1203. (* LevelOf() returns the extension level of the type whose tag is passed
  1204. ** as a parameter. A type with no base type has an extension level of 0;
  1205. ** a type that immediately extends it has a level of 1, and so on. This
  1206. ** procedure relies on the type descriptor structure described above.
  1207. *)
  1208.  
  1209. <*$ < LongVars+ *> (* No global variables used *)
  1210. PROCEDURE LevelOf* ( type : SYS.TYPETAG ) : INTEGER;
  1211.  
  1212.   TYPE TagTable = POINTER [1] TO ARRAY 16 OF SYS.TYPETAG;
  1213.  
  1214.   VAR tags : TagTable; i : INTEGER;
  1215.  
  1216. BEGIN (* LevelOf *)
  1217.   ASSERT (type # NIL, preCondition);
  1218.   tags := SYS.VAL (TagTable, SYS.VAL (LONGINT, type) + 4);
  1219.   i := 0; WHILE (i < 16) & (tags[i] # type) DO INC (i) END;
  1220.   ASSERT (i < 16, invariant);
  1221.   RETURN i
  1222. END LevelOf;
  1223. <*$ > *>
  1224.  
  1225.  
  1226. (* BaseOf() returns the type tag of the base type of 'type' whose level
  1227. ** is 'level'.
  1228. *)
  1229.  
  1230. <*$ < LongVars+ *> (* No global variables used *)
  1231. PROCEDURE BaseOf* ( type : SYS.TYPETAG; level : INTEGER ) : SYS.TYPETAG;
  1232.  
  1233.   TYPE TagTable = POINTER [1] TO ARRAY 16 OF SYS.TYPETAG;
  1234.  
  1235.   VAR tags : TagTable;
  1236.  
  1237. BEGIN (* BaseOf *)
  1238.   ASSERT (type # NIL, preCondition);
  1239.   ASSERT ((level >= 0) & (level < 16), preCondition);
  1240.   tags := SYS.VAL (TagTable, SYS.VAL (LONGINT, type) + 4);
  1241.   RETURN tags [level]
  1242. END BaseOf;
  1243. <*$ > *>
  1244.  
  1245.  
  1246. (* New() allocates a new record from the type tag passed as a parameter.
  1247. ** The type tag is obtained by a call to SYSTEM.TAG.
  1248. *)
  1249.  
  1250. PROCEDURE New * ( VAR v : SYS.PTR; type : SYS.TYPETAG );
  1251. BEGIN (* New *)
  1252.   ASSERT (type # NIL, preCondition);
  1253.   v := NewRecord (type)
  1254. END New;
  1255.  
  1256.  
  1257. (* Allocate() allocates a block of memory with an arbitrary size and with
  1258. ** the given memory requirements. This block will be untraced, and so can
  1259. ** only be referenced through an untagged pointer (system flag # [0]).
  1260. *)
  1261.  
  1262. PROCEDURE Allocate * ( VAR v : SYS.ADDRESS; size : LONGINT; reqs : SET );
  1263.  
  1264.   VAR memBlock : SysBlkPtr; (* Points to the allocated memory. *)
  1265.  
  1266. BEGIN (* Allocate *)
  1267.   ASSERT (size > 0, preCondition);
  1268.   (* Round size up to next multiple of 4 -- VERY IMPORTANT *)
  1269.   size := SYS.AND (size + 3, 0FFFFFFFCH);
  1270.   memBlock := AllocMem (size + SIZE (SysBlk), reqs);
  1271.   IF memBlock # NIL THEN
  1272.     memBlock.size := size + 1;
  1273.     <* IF DEBUG1 THEN *>
  1274.     memBlock.id := SysBlkId;
  1275.     <* END *>
  1276.     ObtainSemaphore(memSem);
  1277.     memBlock.link := untraced; untraced := memBlock;
  1278.     INC (SYS.VAL (LONGINT, memBlock), SIZE (SysBlk));
  1279.     ReleaseSemaphore(memSem);
  1280.   END;
  1281.   v := memBlock
  1282. END Allocate;
  1283.  
  1284.  
  1285. (*-----------------------------------------------------------------------**
  1286. ** The following procedures implement the garbage collector, which is a  **
  1287. ** mark-and-sweep collector based on the algorithm described in the      **
  1288. ** Oberon Technical Notes.                                               **
  1289. **-----------------------------------------------------------------------*)
  1290.  
  1291.  
  1292. (* Mark() is the heart of the garbage collector. It is written in assembly
  1293. ** language for speed, but is too large to be implemented as inline code.
  1294. ** Instead, it is assembled seperetely to the object file "Mark.o",
  1295. ** which is listed as an external library in the module header. See
  1296. ** "Mark.asm" for the source code.
  1297. *)
  1298.  
  1299. PROCEDURE [4] Mark ["Kernel_Mark"] ( q [8] : SYS.LONGWORD );
  1300.  
  1301.  
  1302. (* Sweep() walks the list of traced memory blocks, unmarking any marked
  1303. ** blocks and freeing all unmarked blocks.
  1304. *)
  1305.  
  1306. PROCEDURE Sweep;
  1307.  
  1308.   VAR mem, prev, next : MemBlockPtr;
  1309.  
  1310. BEGIN (* Sweep *)
  1311.   prev := SYS.ADR (traced); next := traced;
  1312.   WHILE next # NIL DO
  1313.     IF 31 IN next.sizeTag THEN
  1314.       (* next is marked, unmark it and move on *)
  1315.       EXCL (next.sizeTag, 31);
  1316.       prev := next;
  1317.       next := next.link
  1318.     ELSE
  1319.       (* unlink the block and free it *)
  1320.       mem := next;
  1321.       next := next.link;
  1322.       prev.link := next;
  1323.       FreeMemBlock (mem)
  1324.     END
  1325.   END
  1326. END Sweep;
  1327.  
  1328.  
  1329. (* GC
  1330. **
  1331. ** The garbage collector.
  1332. *)
  1333.  
  1334. PROCEDURE GC*;
  1335. BEGIN (* GC *)
  1336.   ObtainSemaphore(memSem);
  1337.   SYS.INLINE (
  1338.     048E7H, 0000CH           (*     MOVEM.L A4-A5, -(A7)    *)
  1339.   );
  1340.   SYS.SETREG (14, gcBase);   (*     MOVE.L  gcBase(A4), A6  *)
  1341.   SYS.INLINE (
  1342.     0200EH,                  (* G1: MOVE.L  A6, D0          *)
  1343.     06730H,                  (*     BEQ     G4              *)
  1344.     02A6EH, 00004H,          (*     MOVE.L  varBase(A6), A5 *)
  1345.     0286EH, 00008H,          (*     MOVE.L  offsets(A6), A4 *)
  1346.     02E1CH,                  (* G2: MOVE.L  (A4)+, D7       *)
  1347.     06B20H,                  (*     BMI     G3              *)
  1348.     02035H, 07800H,          (*     MOVE.L  00(A5,D7.L), D0 *)
  1349.     067F6H,                  (*     BEQ     G2              *)
  1350.     02040H,                  (*     MOVE.L  D0, A0          *)
  1351.     008E8H, 7, -4,           (*     BSET    #07,  FFFC(A0)  *)
  1352.     066ECH,                  (*     BNE     G2              *)
  1353.     00828H, 0, -1,           (*     BTST    #00,  FFFF(A0)  *)
  1354.     066E4H                   (*     BNE     G2              *)
  1355.   ); (* INLINE *)
  1356.   Mark (SYS.REG (8));        (*     Call    Kernel_Mark     *)
  1357.   <* IF SMALLCODE THEN *>
  1358.   SYS.INLINE (04E71H);       (*     NOP                     *)
  1359.   <* END *>
  1360.   SYS.INLINE (
  1361.     060DCH,                  (*     BRA     G2              *)
  1362.     02C56H,                  (* G3: MOVE.L  (A6), A6        *)
  1363.     060CCH,                  (*     BRA     G1              *)
  1364.     04CDFH, 03000H           (* G4: MOVEM.L (A7)+, A4-A5    *)
  1365.   ); (* INLINE *)
  1366.   Sweep;                     (*     Call    Kernel_Sweep    *)
  1367.   ReleaseSemaphore(memSem);
  1368. END GC;
  1369.  
  1370.  
  1371. (* InstallTrapHandler()
  1372. **
  1373. ** Installing a trap handler makes life difficult when using a debugger or
  1374. ** profiler, so this procedure is provided to allow the programmer to
  1375. ** decide if the trap handler should be installed or not.
  1376. *)
  1377.  
  1378. PROCEDURE InstallTrapHandler*;
  1379.   VAR t : LONGINT;
  1380. BEGIN (* InstallTrapHandler *)
  1381.   IF ~handlerInstalled THEN
  1382.     (* Allocate the traps recognised by the handler *)
  1383.  
  1384.     userTraps := {};
  1385.     FOR t := 0 TO 6 DO
  1386.       ASSERT (AllocTrap (t) >= 0, userTrap);
  1387.       INCL (userTraps, t)
  1388.     END;
  1389.  
  1390.     (* Replace the existing trap handler with one of our own. *)
  1391.  
  1392.     oldTrapCode := process.trapCode;
  1393.     oldTrapData := process.trapData;
  1394.     process.trapCode := TrapHandler;
  1395.     process.trapData := NIL;
  1396.     handlerInstalled := TRUE
  1397.   END;
  1398. END InstallTrapHandler;
  1399.  
  1400.  
  1401. (*
  1402. ** RemoveTrapHandler()
  1403. **
  1404. ** Removes the trap handler.
  1405. *)
  1406.  
  1407. PROCEDURE RemoveTrapHandler*;
  1408.   VAR t : LONGINT;
  1409. BEGIN (* RemoveTrapHandler *)
  1410.   IF handlerInstalled THEN
  1411.     FOR t := 0 TO 6 DO IF t IN userTraps THEN FreeTrap (t) END END;
  1412.     process.trapCode := oldTrapCode;
  1413.     process.trapData := oldTrapData;
  1414.     handlerInstalled := FALSE
  1415.   END
  1416. END RemoveTrapHandler;
  1417.  
  1418.  
  1419. (*-----------------------------------------------------------------------**
  1420. ** Procedures for registering and searching modules, types and commands  **
  1421. **-----------------------------------------------------------------------*)
  1422.  
  1423.  
  1424. PROCEDURE FindName ( list : RegNode; name : ARRAY OF CHAR ) : RegNode;
  1425.  
  1426.   VAR next : RegNode;
  1427.  
  1428. <*$CopyArrays-*>
  1429. BEGIN (* FindName *)
  1430.   next := list;
  1431.   WHILE (next # NIL) & (next.name # name) DO next := next.next END;
  1432.   RETURN next
  1433. END FindName;
  1434.  
  1435.  
  1436. PROCEDURE RegisterModule* ( name : ARRAY OF CHAR ) : Module;
  1437.  
  1438.   VAR module : Module;
  1439.  
  1440. <*$CopyArrays-*>
  1441. BEGIN (* RegisterModule *)
  1442.   module := NewSysBlk (SIZE (ModuleDesc), FALSE);
  1443.   ASSERT (module # NIL, outOfMem);
  1444.   COPY (name, module.name);
  1445.   module.next := modules; modules := module;
  1446.   RETURN module
  1447. END RegisterModule;
  1448.  
  1449.  
  1450. PROCEDURE FindModule* ( name : ARRAY OF CHAR ) : Module;
  1451. <*$CopyArrays-*>
  1452. BEGIN (* FindModule *)
  1453.   RETURN SYS.VAL (Module, FindName (modules, name))
  1454. END FindModule;
  1455.  
  1456.  
  1457. PROCEDURE RegisterType* ( module : Module; tag : SYS.TYPETAG ) : Type;
  1458.  
  1459.   VAR type : Type; name : ARRAY 64 OF CHAR; i, j : INTEGER; ch : CHAR;
  1460.  
  1461. BEGIN (* RegisterType *)
  1462.   ASSERT (module # NIL, preCondition);
  1463.   type := NewSysBlk (SIZE (TypeDesc), FALSE);
  1464.   ASSERT (type # NIL, outOfMem);
  1465.   Name (tag, name);
  1466.   i := 0; WHILE name[i] # "." DO INC (i) END; INC (i);
  1467.   ASSERT ((SYS.STRLEN (name) - i) < 32, invariant);
  1468.   j := 0;
  1469.   REPEAT type.name[j] := name[i]; INC (j); INC (i) UNTIL name[i] = 0X;
  1470.   type.tag := tag; type.next := module.types; module.types := type;
  1471.   RETURN type
  1472. END RegisterType;
  1473.  
  1474.  
  1475. PROCEDURE FindType* ( module : Module; name : ARRAY OF CHAR ) : Type;
  1476. <*$CopyArrays-*>
  1477. BEGIN (* FindType *)
  1478.   ASSERT (module # NIL, preCondition);
  1479.   RETURN SYS.VAL (Type, FindName (module.types, name))
  1480. END FindType;
  1481.  
  1482.  
  1483. PROCEDURE RegisterCommand*
  1484.   ( module : Module; name : ARRAY OF CHAR; proc : CommandProc )
  1485.   : Command;
  1486.  
  1487.   VAR command : Command;
  1488.  
  1489. <*$CopyArrays-*>
  1490. BEGIN (* RegisterCommand *)
  1491.   ASSERT (module # NIL, preCondition);
  1492.   command := NewSysBlk (SIZE (CommandDesc), FALSE);
  1493.   ASSERT (command # NIL, outOfMem);
  1494.   COPY (name, command.name); command.proc := proc;
  1495.   command.next := module.commands; module.commands := command;
  1496.   RETURN command
  1497. END RegisterCommand;
  1498.  
  1499.  
  1500. PROCEDURE FindCommand* ( module : Module; name : ARRAY OF CHAR ) : Command;
  1501. <*$CopyArrays-*>
  1502. BEGIN (* FindCommand *)
  1503.   ASSERT (module # NIL, preCondition);
  1504.   RETURN SYS.VAL (Command, FindName (module.commands, name))
  1505. END FindCommand;
  1506.  
  1507.  
  1508. (*-----------------------------------------------------------------------**
  1509. ** Procedures for installing finalization procedures.                    **
  1510. **-----------------------------------------------------------------------*)
  1511.  
  1512.  
  1513. PROCEDURE RegisterObject* ( obj : SYS.PTR; fin : Finalizer );
  1514. BEGIN (* RegisterObject *)
  1515.   HALT (notImplemented)
  1516. END RegisterObject;
  1517.  
  1518.  
  1519. PROCEDURE RegisterStruct* ( str : SYS.ADDRESS; fin : StructFinalizer );
  1520. BEGIN (* RegisterStruct *)
  1521.   HALT (notImplemented)
  1522. END RegisterStruct;
  1523.  
  1524.  
  1525. (*-----------------------------------------------------------------------**
  1526. ** Obtain the data segment from the Task.userData structure and put it   **
  1527. ** into A4.                                                              **
  1528. **-----------------------------------------------------------------------*)
  1529.  
  1530. <*$ < LongVars+ *>
  1531. PROCEDURE GetDataSegment*;
  1532.  
  1533. <* IF SMALLDATA OR RESIDENT THEN *>
  1534. <*$ EntryExitCode- *>
  1535. BEGIN (* GetDataSegment *)
  1536.   SYS.INLINE (
  1537.     02878H, 00004H,       (*    MOVE.L 4.W,A4       *)
  1538.     0286CH, 00114H,       (*    MOVE.L 0114(A4), A4 *)
  1539.     0286CH, 00058H,       (*    MOVE.L 0058(A4), A4 *)
  1540.     0286CH, 00004H,       (*    MOVE.L 0004(A4), A4 *)
  1541.     04E75H                (*    RTS                 *)
  1542.   ); (* INLINE *)
  1543. <* END *>
  1544. END GetDataSegment;
  1545. <*$ > *>
  1546.  
  1547. (*-----------------------------------------------------------------------**
  1548. ** This module initialisation is the first Oberon code executed by a     **
  1549. ** program. It is called from a short code prologue placed at the very   **
  1550. ** start of the program.                                                 **
  1551. **-----------------------------------------------------------------------*)
  1552.  
  1553. <*$ClearVars+*>
  1554. BEGIN (* Kernel *)
  1555.  
  1556.   (* Dos passes the command line and its length in A0/D0. These must be
  1557.   ** saved, as well as the initial stack pointer.
  1558.   *)
  1559.  
  1560.   SYS.GETREG (8, dosCmdBuf);
  1561.   SYS.GETREG (0, dosCmdLen);
  1562.   SYS.GETREG (15, initialSP);
  1563.   INC (initialSP, 4); (* Allow for the JSR that got us here. *)
  1564.  
  1565.   (* Get SysBase *)
  1566.   SYS.GET (AbsExecBase, SysBase);
  1567.  
  1568.   (* Now find our Process structure and see if we are run from the Shell
  1569.   ** or the Workbench.
  1570.   *)
  1571.   process := SYS.VAL (ProcessPtr, FindTask (NIL));
  1572.   fromWorkbench := (process.cli = NIL);
  1573.  
  1574.   IF fromWorkbench THEN
  1575.     (* The program was run by Workbench. We must wait for a startup
  1576.     ** message at the process message port and clear it immediately. The
  1577.     ** message must be saved, to be replied when the program exits.
  1578.     *)
  1579.     WaitPort (process.msgPort);
  1580.     WBenchMsg := GetMsg (process.msgPort);
  1581.   END;
  1582.  
  1583.   (* Set up the Task.userData field. *)
  1584.   userData.userData := process.userData;
  1585. <* IF SMALLDATA OR RESIDENT THEN *>
  1586.   SYS.GETREG (12, userData.dataSegment);
  1587. <* ELSE *>
  1588.   userData.dataSegment := NIL;
  1589. <* END *>
  1590.   process.userData := SYS.ADR (userData);
  1591.  
  1592.   (* Attempt to open the math library. *)
  1593.  
  1594.   mathBase := OpenLibrary ("mathieeesingbas.library", 33);
  1595.   ASSERT (mathBase # NIL, noLibrary);
  1596.  
  1597.   (* Init the allocation semaphore *)
  1598.   InitSemaphore(memSem);
  1599.  
  1600. <* IF ~RESIDENT THEN *>
  1601.   (* D1 is non-zero when the main body starts. It must be zero on exit *)
  1602.   SYS.SETREG (1, 0)
  1603. <* END *>
  1604. END Kernel.
  1605.  
  1606. (*************************************************************************
  1607.  
  1608.   $Log: Kernel.mod $
  1609.   Revision 1.9  1995/06/15  18:30:11  fjc
  1610.   - Added semaphore guards to memory lists [Helmuth Ritzer].
  1611.  
  1612.   Revision 1.8  1995/06/04  23:22:06  fjc
  1613.   - Release 1.6
  1614.  
  1615.   Revision 1.7  1995/05/08  16:48:05  fjc
  1616.   - General improvements to memory allocation procedures.
  1617.   - Changed handling of global variable offsets by the garbage
  1618.     collector.
  1619.   - Added interface to Finalization facility, to be
  1620.     implemented at a later date.
  1621.  
  1622.   Revision 1.6  1995/02/07  20:28:47  fjc
  1623.   - Added registration of modules, types and commands
  1624.  
  1625.   Revision 1.5  1995/01/26  00:37:31  fjc
  1626.   - Release 1.5
  1627.  
  1628.   Revision 1.4  1995/01/09  18:25:03  fjc
  1629.   - Incorporated changes in interfaces
  1630.  
  1631.   Revision 1.3  1994/11/11  16:44:48  fjc
  1632.   - Uses new external code interface.
  1633.  
  1634.   Revision 1.2  1994/09/18  20:53:39  fjc
  1635.   - Converted switches to pragmas/options
  1636.  
  1637.   Revision 1.1  1994/08/22  21:50:29  fjc
  1638.   Initial revision
  1639.  
  1640. *************************************************************************)
  1641.  
  1642.